home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / program / 674 / start / start.gfa (.txt) < prev    next >
Encoding:
GFA-BASIC Atari  |  1986-10-19  |  10.4 KB  |  491 lines
  1. ' *****************
  2. ' *** START.GFA ***
  3. ' *****************
  4. ' *** this program runs in High or Medium resolution
  5. ' *** 'Shell'-program for running *.GFA-programs (must be in main directory)
  6. ' *** GFA-programs should exit with CHAIN "\START.GFA"
  7. ' *** © Han Kempen (22-4-1990)
  8. '
  9. DEFWRD "a-z"
  10. '
  11. start$="\START.INF"             ! last path saved here
  12. scrn.col.max&=80                 ! screenwidth 80 characters
  13. '
  14. CLS
  15. ' @check.boot                   ! check for boot-virus (not activated)
  16. @high.med.mode                  ! check resolution : quit if Low rez
  17. '
  18. drive$=CHR$(65+GEMDOS(25))      ! problem : this is the GFABASIC.PRG-drive !
  19. '
  20. bytes%=DFREE(0)                 ! slow on harddisk (unless FATSPEED installed)
  21. current$="p "+drive$+" q "+STR$(bytes%)+" bytes free"
  22. '
  23. IF EXIST(start$)
  24.   OPEN "I",#1,start$            ! last accessed folder in file START.INF
  25.   INPUT #1,path$
  26.   CLOSE #1
  27. ELSE
  28.   path$=drive$+":"+"\"          ! main directory
  29. ENDIF
  30. '
  31. IF XBIOS(4)=2
  32.   high.res!=TRUE
  33.   y.fac&=1
  34. ELSE
  35.   med.res!=TRUE
  36.   y.fac&=2                       ! half as many y-pixels in medium resolution
  37. ENDIF
  38. '
  39. IF high.res!
  40.   VSETCOLOR 1,0                 ! black letters on white background
  41. ELSE
  42.   @standard.med.colors
  43. ENDIF
  44. '
  45. IF PEEK(&H444)<>0               ! first time after reset ? (not perfect !)
  46.   IF med.res!
  47.     SPOKE &HFF820A,252          ! * NOT * if you use a TV through a modulator !
  48.     PRINT
  49.     PRINT " Vertical frequency now 60 Hz"
  50.   ENDIF
  51.   '
  52.   SPOKE &H444,0
  53.   PRINT
  54.   PRINT " Write Verify Test switched off"
  55.   '
  56.   IF VAL(RIGHT$(DATE$,2))<88            ! date not set ? (not perfect either)
  57.     HIDEM
  58.     LOCATE 1,9
  59.     PRINT @center$("START-SHELL")
  60.     LOCATE 1,17
  61.     PRINT @center$("GFA-BASIC 3.0")
  62.     DEFLINE 1,5
  63.     RBOX 22*8,10*16/y.fac&,58*8,15*16/y.fac&
  64.     LOCATE 25,12
  65.     @start.date.input
  66.     LOCATE 25,14
  67.     @start.time.input                   ! just press <Return> if you don't care
  68.     DEFLINE 1,1
  69.     SHOWM
  70.   ENDIF
  71.   '
  72. ENDIF
  73. '
  74. SELECT DPEEK(&H4A6)             ! first check if two drives connected
  75. CASE 1
  76.   drive$="A "
  77. CASE 2
  78.   drive$="A B "
  79. ENDSELECT
  80. FOR n&=2 TO 15                   ! now check other drives (harddisk, RAM-disk)
  81.   IF BTST(BIOS(10),n&)
  82.     drive$=drive$+CHR$(n&+65)+" "
  83.   ENDIF
  84. NEXT n&
  85. '
  86. CLS
  87. left$="START - SHELL"
  88. DEFTEXT ,2,900,32
  89. TEXT 100,350/y.fac&,300/y.fac&,left$
  90. right$="GFA-BASIC 3.0"
  91. DEFTEXT ,,2700
  92. TEXT 540,50/y.fac&,300/y.fac&,right$
  93. DEFTEXT ,0,0,13
  94. bottom$="drives: "+drive$+"     "+current$
  95. PRINT AT(1,25);@center$(bottom$);
  96. '
  97. m$="Choose *.GFA-file      <Cancel> = Quit"
  98. REPEAT
  99.   @fileselect(path$+"*.GFA","",m$,file$)
  100. UNTIL file$="" OR RIGHT$(file$)="\" OR RIGHT$(file$,4)=".GFA"
  101. '
  102. CLS
  103. IF file$="" OR RIGHT$(file$)="\"
  104.   ' *** user wants to quit
  105.   IF EXIST(start$)
  106.     KILL start$                         ! kill file START.INF
  107.   ENDIF
  108.   SETMOUSE 320,200/y.fac&+26
  109.   m$="|Go to GFA-editor|       or|return to Desktop ?"
  110.   ALERT 3,m$,1,"EDIT|DESK",k&
  111.   IF k&=1
  112.     NEW
  113.   ELSE
  114.     SYSTEM
  115.   ENDIF
  116. ELSE
  117.   ' *** user chose GFA-program
  118.   @parse.filename(file$,d$,p$,f$,e$)
  119.   path$=d$+":"+p$
  120.   OPEN "O",#1,start$
  121.   PRINT #1,path$        ! remember last path
  122.   CLOSE #1
  123.   CHDRIVE path$
  124.   CHDIR path$           ! essential for Standard Procedure Get.path in file$ !!
  125.   CHAIN file$           ! start the GFA-program
  126. ENDIF
  127. '
  128. ' ------------------------------------------------------------------------------
  129. '
  130. DEFFN center$(text$)=SPACE$((scrn.col.max&-LEN(text$))/2)+text$
  131. '
  132. > PROCEDURE check.boot
  133.   ' *** compute checksum of bootsector and warn user if bootsector executable
  134.   LOCAL drive&,buffer$,buffer%,sum%,n&,m$
  135.   PRINT " Checking boot-sector ..."
  136.   drive&=GEMDOS(&H19)
  137.   buffer$=SPACE$(512)
  138.   buffer%=VARPTR(buffer$)
  139.   ~BIOS(4,0,L:buffer%,1,0,drive&)    ! bootsector (0) of current drive in buffer
  140.   sum%=0
  141.   FOR n&=0 TO 255
  142.     ADD sum%,CARD{buffer%+n&*2}
  143.   NEXT n&
  144.   sum%=sum% AND &HFFFF
  145.   IF sum%=&H1234
  146.     m$="Bootsector|executable :|this could be|a boot-virus"
  147.     ALERT 3,m$,2," OK |STOP",k&
  148.   ENDIF
  149. RETURN
  150. ' **********
  151. '
  152. > PROCEDURE high.med.mode
  153.   LOCAL m$,button&
  154.   IF XBIOS(4)=0
  155.     SOUND 1,10,12,4,25
  156.     SOUND 1,10,6,4,25
  157.     SOUND 1,10,12,4,50
  158.     SOUND 1,0
  159.     m$="Sorry, use|High or Medium|resolution for|this program"
  160.     ALERT 3,m$,1," OK ",button&
  161.     IF EXIST(interpreter$)
  162.       EDIT
  163.     ELSE
  164.       SYSTEM
  165.     ENDIF
  166.   ENDIF
  167. RETURN
  168. ' **********
  169. '
  170. > PROCEDURE get.path(VAR default.path$)
  171.   ' *** return default path (current drive and folder)
  172.   ' *** example - A:\GAMES\
  173.   LOCAL default.drive&,default.drive$
  174.   CLR default.path$
  175.   default.drive&=GEMDOS(&H19)
  176.   default.drive$=CHR$(default.drive&+65)
  177.   default.path$=DIR$(default.drive&+1)
  178.   IF default.path$<>""
  179.     default.path$=default.drive$+":"+default.path$+"\"
  180.   ELSE
  181.     default.path$=default.drive$+":\"
  182.   ENDIF
  183. RETURN
  184. ' **********
  185. '
  186. > PROCEDURE standard.med.colors
  187.   ' *** standard-colors for Medium resolution
  188.   LOCAL n&,col$,r&,g&,b&
  189.   RESTORE col.data
  190.   FOR n&=0 TO 3
  191.     READ col$
  192.     r&=VAL(LEFT$(col$))
  193.     g&=VAL(MID$(col$,2,1))
  194.     b&=VAL(RIGHT$(col$))
  195.     VSETCOLOR n&,r&,g&,b&
  196.   NEXT n&
  197.   '
  198. col.data:
  199.   DATA 777,000,700,060
  200. RETURN
  201. ' **********
  202. '
  203. > PROCEDURE start.date.input
  204.   ' *** input of date
  205.   ' *** accepts different formats (day-month-year), e.g. :
  206.   ' *** 1-6-'88   02-11-88   3.6.88   2/1/88   12 June 1988   9 Aug 88
  207.   LOCAL x&,y&,date.input$,ok!,day$,day&,month.input$,month$,n&,month!,month&,year$,year&
  208.   LOCAL new.date$
  209.   PRINT " Date (dd.mm.yy)   : ";
  210.   x&=CRSCOL
  211.   y&=CRSLIN
  212.   ON ERROR GOSUB start.date.input.error
  213.   '
  214. start.date.input:
  215.   ' *** input of date
  216.   ok!=TRUE
  217.   FORM INPUT 18,date.input$
  218.   ' *** day
  219.   day.len&=VAL?(date.input$)
  220.   IF day.len&>2
  221.     IF INSTR(date.input$,".")=2
  222.       day.len&=1
  223.     ELSE
  224.       IF INSTR(date.input$,".")=3
  225.         day.len&=2
  226.       ELSE
  227.         ok!=FALSE
  228.       ENDIF
  229.     ENDIF
  230.   ENDIF
  231.   day$=LEFT$(date.input$,day.len&)
  232.   day&=VAL(day$)
  233.   IF day&>31 OR day&<1
  234.     ok!=FALSE
  235.   ENDIF
  236.   ' *** mmonth
  237.   month.input$=RIGHT$(date.input$,LEN(date.input$)-(day.len&+1))
  238.   month.len&=VAL?(month.input$)
  239.   IF month.len&=0
  240.     month$=LEFT$(month.input$,3)
  241.     month$=UPPER$(month$)
  242.   start.month.data:
  243.     DATA JAN,1,FEB,2,MAR,3,APR,4,MAY,5,JUN,6,JUL,7
  244.     DATA AUG,8,SEP,9,OCT,10,NOV,11,DEC,12
  245.     DIM date.input.month$(12),date.input.month&(12)
  246.     RESTORE start.month.data
  247.     FOR n&=1 TO 12
  248.       READ date.input.month$(n&),date.input.month&(n&)
  249.     NEXT n&
  250.     FOR n&=1 TO 12
  251.       IF date.input.month$(n&)=month$
  252.         month!=TRUE
  253.         month&=date.input.month&(n&)
  254.       ENDIF
  255.     NEXT n&
  256.     ERASE date.input.month$()
  257.     ERASE date.input.month&()
  258.     IF NOT month!
  259.       ok!=FALSE
  260.     ENDIF
  261.   ELSE
  262.     month&=VAL(month.input$)
  263.   ENDIF
  264.   IF month&>12 OR month&<1
  265.     ok!=FALSE
  266.   ENDIF
  267.   month$=STR$(month&)
  268.   IF (month&=4 OR month&=6 OR month&=9 OR month&=11) AND day&>30
  269.     ok!=FALSE
  270.   ENDIF
  271.   IF (month&=1 OR month&=3 OR month&=5 OR month&=7 OR month&=8 OR month&=10 OR month&=12) AND day&>31
  272.     ok!=FALSE
  273.   ENDIF
  274.   ' *** year
  275.   year$=RIGHT$(date.input$,2)
  276.   IF VAL?(year$)<>2 OR INSTR(year$,".") OR VAL(year$)<88
  277.     ok!=FALSE
  278.   ENDIF
  279.   year&=VAL(year$)
  280.   IF month&=2
  281.     IF day&>28
  282.       IF (year& MOD 400=0) AND day&<>29
  283.         ok!=FALSE
  284.       ELSE
  285.         IF year& MOD 100=0 AND (year& MOD 400<>0)
  286.           ok!=FALSE
  287.         ELSE
  288.           IF (year& MOD 4=0) AND day&<>29
  289.             ok!=FALSE
  290.           ELSE
  291.             IF (year& MOD 4<>0)
  292.               ok!=FALSE
  293.             ENDIF
  294.           ENDIF
  295.         ENDIF
  296.       ENDIF
  297.     ENDIF
  298.   ENDIF
  299.   ' *** print date
  300.   IF NOT ok!
  301.     PRINT CHR$(7);
  302.     PRINT AT(x&,y&);STRING$(LEN(date.input$)," ");
  303.     PRINT AT(x&,y&);"WRONG FORMAT !!";
  304.     PAUSE 50
  305.     PRINT AT(x&,y&);STRING$(18," ");
  306.     PRINT AT(x&,y&);"";
  307.     RBOX 22*8,10*16/fac&,58*8,15*16/fac&
  308.     GOTO start.date.input
  309.   ENDIF
  310.   LET new.date$=day$+"."+month$+"."+year$
  311.   SETTIME TIME$,new.date$
  312.   ON ERROR
  313. RETURN
  314. ' ***
  315. > PROCEDURE start.date.input.error
  316.   ' *** unexpected error
  317.   ok!=FALSE
  318.   ON ERROR GOSUB start.date.input.error
  319.   RESUME NEXT
  320. RETURN
  321. ' **********
  322. '
  323. > PROCEDURE start.time.input
  324.   ' *** input of time (seconds optional)
  325.   ' *** <Return> = 00:00:00
  326.   ' *** accepts different formats, e.g. :
  327.   ' *** 12.40.10    1:30:25    20.45
  328.   '
  329.   LOCAL x&,y&,ok!,time.input$,hour.len&,hour$,minute.input$,minute.len&
  330.   LOCAL minute$,second$,second.input$,second.len&,new.time$
  331.   PRINT " Time (hh.mm[.ss]) : ";
  332.   x&=CRSCOL
  333.   y&=CRSLIN
  334.   ON ERROR GOSUB start.time.input.error
  335.   '
  336. start.time.input:
  337.   ' *** input of time
  338.   ok!=TRUE
  339.   FORM INPUT 10,time.input$
  340.   IF time.input$=""
  341.     LET new.time$="00:00:00"
  342.     GOTO start.time.exit
  343.   ENDIF
  344.   ' *** hour
  345.   hour.len&=VAL?(time.input$)
  346.   IF hour.len&>2
  347.     IF INSTR(time.input$,".")=2
  348.       hour.len&=1
  349.     ELSE
  350.       IF INSTR(time.input$,".")=3
  351.         hour.len&=2
  352.       ELSE
  353.         ok!=FALSE
  354.       ENDIF
  355.     ENDIF
  356.   ENDIF
  357.   hour$=LEFT$(time.input$,hour.len&)
  358.   IF VAL(hour$)>23
  359.     ok!=FALSE
  360.   ENDIF
  361.   ' *** minutes
  362.   LET minute.input$=RIGHT$(time.input$,LEN(time.input$)-(hour.len&+1))
  363.   LET minute.len&=VAL?(minute.input$)
  364.   IF minute.len&>2
  365.     IF INSTR(minute.input$,".")=2
  366.       LET minute.len&=1
  367.     ELSE
  368.       IF INSTR(minute.input$,".")=3
  369.         LET minute.len&=2
  370.       ELSE
  371.         ok!=FALSE
  372.       ENDIF
  373.     ENDIF
  374.   ENDIF
  375.   LET minute$=LEFT$(minute.input$,minute.len&)
  376.   IF VAL(minute$)>59
  377.     ok!=FALSE
  378.   ENDIF
  379.   ' *** seconds
  380.   IF minute.len&>=LEN(minute.input$)-1
  381.     second$="0"
  382.   ELSE
  383.     second.input$=RIGHT$(minute.input$,LEN(minute.input$)-(minute.len&+1))
  384.     second$=LEFT$(second.input$,2)
  385.     IF VAL(second$)>59
  386.       ok!=FALSE
  387.     ENDIF
  388.   ENDIF
  389.   ' *** tijd
  390.   IF NOT ok!
  391.     PRINT CHR$(7);
  392.     PRINT AT(x&,y&);STRING$(LEN(time.input$)," ");
  393.     PRINT AT(x&,y&);"WRONG !!";
  394.     PAUSE 50
  395.     PRINT AT(x&,y&);STRING$(10," ");
  396.     PRINT AT(x&,y&);"";
  397.     RBOX 22*8,10*16/fac&,58*8,15*16/fac&
  398.     GOTO start.time.input
  399.   ENDIF
  400.   LET new.time$=hour$+":"+minute$+":"+second$
  401. start.time.exit:
  402.   SETTIME new.time$,DATE$
  403.   ON ERROR
  404. RETURN
  405. ' ***
  406. > PROCEDURE start.time.input.error
  407.   ' *** unexpected error
  408.   ok!=FALSE
  409.   ON ERROR GOSUB start.time.input.error
  410.   RESUME NEXT
  411. RETURN
  412. ' **********
  413. '
  414. > PROCEDURE fileselect(path$,default$,txt$,VAR file$)
  415.   ' *** use Fileselector with comment-line
  416.   ' *** comment-line max. 38 characters in all resolutions
  417.   ' *** uses Standard Function and Globals
  418.   PRINT AT(1,3);@center$(txt$)
  419.   GRAPHMODE 3
  420.   DEFFILL 1,1           ! black
  421.   BOUNDARY 0
  422.   IF high.res!
  423.     BOX 157,25,482,54
  424.     PLOT 157,25
  425.     PBOX 159,27,480,52
  426.   ELSE IF med.res!
  427.     BOX 157,12,482,27
  428.     PLOT 157,12
  429.     PBOX 160,14,479,24
  430.   ELSE IF low.res!
  431.     BOX 0,12,319,27
  432.     PLOT 0,12
  433.     PBOX 2,14,317,24
  434.   ENDIF
  435.   BOUNDARY 1
  436.   GRAPHMODE 1
  437.   FILESELECT path$,default$,file$
  438. RETURN
  439. ' **********
  440. '
  441. > PROCEDURE parse.filename(parse.name$,VAR drive$,path$,file$,ext$)
  442.   ' *** return drive, path, filename (without extension !) and extension
  443.   ' *** no checking for correct syntax
  444.   ' *** example : "A:\GAMES\PLAY.GFA" returned as :  A  \GAMES\  PLAY  GFA
  445.   ' ***           "A:\PLAY.GFA"       returned as :  A  \        PLAY  GFA
  446.   LOCAL pos&,first&,last&,last!,search&,parse.file$
  447.   '
  448.   parse.name$=UPPER$(parse.name$)
  449.   IF MID$(parse.name$,2,1)=":"
  450.     drive$=LEFT$(parse.name$,1)
  451.   ELSE
  452.     drive$=CHR$(65+GEMDOS(&H19))    ! current drive
  453.   ENDIF
  454.   '
  455.   pos&=1
  456.   last!=FALSE
  457.   last&=0
  458.   first&=INSTR(1,parse.name$,"\")
  459.   REPEAT
  460.     search&=INSTR(pos&,parse.name$,"\")
  461.     IF search&>0
  462.       pos&=search&+1
  463.       last&=search&
  464.     ELSE
  465.       last!=TRUE
  466.     ENDIF
  467.   UNTIL last!
  468.   IF last&>0                              ! backslash discovered
  469.     path$=MID$(parse.name$,first&,last&-first&+1)
  470.     parse.file$=MID$(parse.name$,last&+1)
  471.   ELSE                                   ! no '\'
  472.     path$=""
  473.     pos&=INSTR(1,parse.name$,":")
  474.     IF pos&>0
  475.       parse.file$=MID$(parse.name$,pos&+1)
  476.     ELSE
  477.       parse.file$=parse.name$
  478.     ENDIF
  479.   ENDIF
  480.   pos&=INSTR(parse.file$,".")
  481.   IF pos&>0                               ! name with extension
  482.     ext$=MID$(parse.file$,pos&+1)
  483.     file$=LEFT$(parse.file$,pos&-1)
  484.   ELSE                                   ! name without extension
  485.     ext$=""
  486.     file$=parse.file$
  487.   ENDIF
  488. RETURN
  489. ' **********
  490. '
  491.